MacWorld 1999 July

home *** CD-ROM | disk | FTP | other *** search

/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / PPC source / pnuc4 < prev next >

Wrap

Text File | 1999-02-05 | 18KB | 708 lines

\ ================================== \ DICTIONARY LOOKUP \ ================================== : THREAD ( str-addr -- thread-addr ) c@ 7 and 2 << context + ; : (FIND) { string-addr lfa \ 1st_wd dic-addr str-addr n mismatch? mask flag_byte -- xt flag | -- string-addr false } \ lfa points to the dictionary entry where the search is to start. \ first we do a fast check on the length byte and first 3 bytes, then, if \ this succeeds, we check the full length, 4 bytes at a time. Note names \ are always aligned and padded out to a 4-byte boundary with zeros. $ 1fffffff -> mask string-addr @ mask and -> 1st_wd BEGIN lfa 4+ -> dic-addr dic-addr @ 1st_wd xor mask and NIF \ 1st wds match - do full-length check, using \ the string length (as the dic entry may have \ the $20 bit set, which we're ignoring on the \ 68k). string-addr c@ $ 3F and 2 >> -> n false -> mismatch? string-addr -> str-addr dic-addr c@ -> flag_byte BEGIN n WHILE 4 ++> str-addr 4 ++> dic-addr str-addr @ dic-addr @ = NIF \ mismatch - bail out of inner loop and \ return to main loop true -> mismatch? 1 -> n THEN 1 --> n REPEAT mismatch? NIF \ found! dic-addr 6 + \ return xt flag_byte $ 40 and IF 1 ELSE -1 THEN \ and flag (1 immed, -1 non-immed) EXIT THEN THEN lfa @ dup NIF \ failed drop string-addr false EXIT ELSE ++> lfa THEN AGAIN ; forward initFind :f initFind false ;f : FIND ( str-addr -- xt flag | str-addr -- false ) initFind ?dup ?EXIT <'> extraFind 2+ @abs @ IF \ extraFind has a non-default action set - let's execute it: extraFind ?dup ?EXIT THEN dup thread displace (find) ; (* (findM) is the lowest-level routine to search through the linked-list of methods/ivars for the given selector. We also set meth_seg# to the seg# of a found method, which helps us set the module base registers properly if the method is in a module. We don't worry about what we leave in meth_seg# if we don't find the method, or if we're looking for an ivar, so we shouldn't ever rely on it in these cases. We put the class offset constants here, since we need some for (findM): Note that these MUST AGREE with the definitions in qpClass and zClass! *) : MFA_offset ( selID ^class -- selID ^class MFA_offset ) over dup 5 >> + $ 1C and 2 + ; 34 constant IFA_offset : FFA inline{ } ; \ Flags : MFA ( SelID ^Class -- SelID MFA ) inline{ MFA_offset +} ; : IFA inline{ IFA_offset +} ; \ ivar link : DFA inline{ 40 +} ; \ Data len (2 bytes), \ width of indexed elts (2 bytes) : XOFFA inline{ 44 +} ; \ indexing offset for large_obj_arrays : SFA inline{ 46 +} ; \ Superclass N-way pointer 46 constant classSize \ total size of class info up to N-way 0 value methSearch? 0 value selfRef? 0 value sch_offset 0 value sch_selID 0 value searchedClass 0 value findmTest? forward sch_in_class : search_superclasses { ^n-way \ supOffs ^class hdlr svHeldMod svHMS HMsaved? -- offs ^meth/ivar T | -- F } 0 -> supOffs \ initial base offset false -> HMsaved? \ not saving heldMod yet BEGIN ^n-way @ NIF false EXIT THEN \ end of n-way - search failed ^n-way @abs -> ^class \ get the superclass sups2skip \ are we to skip this superclass? IF \ yes - decrement skip count and skip it -1 ++> sups2skip ELSE \ no - we do the search: last_RP_seg# dup -> meth_seg# \ in case we find the method here (* First, we may need to save heldMod and heldModStart over the recursive call. We only need to do this if: 1. The class is in the main dic, and we're in a module. 2. The class is in a module, and we're either in the main dic or in a different module. So what we do, is check if we're in a module and the class is in the SAME module, since this is easy to check for, and in all other cases save heldMod and clear it. If we're in the main dic and the class is in the main dic, we'll be saving and restoring unnecessarily, but it's harmless, and anyway we don't know if we're going into a module until we call ?>classInMod. *) ( last_RP_seg# ) 9 > heldMod and \ true iff we're in a mod and the \ class is in the SAME module NIF heldMod -> svHeldMod \ save heldMod and heldModStart heldModStart -> svHMS true -> HMsaved? 0 -> heldMod \ will be set by ?>classInMod if we go \ into a module, otherwise it will \ stay zero ^class ?>classInMod -> ^class \ if class is exported, go into the module heldMod ?dup IF 4+ w@ -> meth_seg# THEN \ seg#_accessed ?dup IF -> meth_seg# THEN \ and if we did, set meth_seg# to the seg# \ in case we find the method there THEN ^class sch_in_class \ search the class IF \ found! swap supOffs + swap \ update offs by whatever \ sch_in_class returned \ We don't restore any saved heldMod value in this case. \ ** special note: here in the 68k version we unhold any saved heldMod, \ after checking if it's different to the one the search succeeded in. \ But now we're never unlocking modules, so I'm omitting this, to keep \ things a bit simpler. true EXIT ELSE \ search failed in that class HMsaved? IF ?unHoldMod \ unhold the mod we just searched in svHeldMod -> heldMod \ and restore heldMod etc. svHMS -> heldModStart THEN THEN THEN ^class DFA w@ #align 4+ ++> supOffs \ not found - update offset by ivar len of that \ superclass, plus alignment and the 2 2-byte \ offsets we put between embedded objects \ (^class and indexed area offsets) 4 ++> ^n-way AGAIN ; :f sch_in_class { ^class \ addr selID -- offs ^meth/ivar T | -- F } ^class -> searchedClass \ we need this in a few places ^class sch_offset + -> addr \ head of linked list for search BEGIN \ addr @ NIF false EXIT THEN \ zero link - search failed \ addr displace -> addr \ follow link addr @ dup 0EXIT ++> addr addr @ -> selID selID 0> IF \ positive - so it's an n-way, not a selID at all addr ( ^n-way ) search_superclasses EXIT THEN selID sch_selID = IF \ may be a match - but if a method, \ we have to check if it's private methSearch? IF addr 8 + w@ \ get the flags 1 and not \ it's a match if it's public (bit is zero) selfref? or \ or a reference to self or super dup IF 14 ++> addr THEN \ update addr to 'xt' of method ELSE true \ ivar search - it's a match no matter what, \ and we return the addr of the start of the \ ivar's info. \ 4 ++> addr \ update addr to class pointer THEN ( match? ) IF \ found! 0 \ always return zero offset from non-MI search addr \ addr of matching meth/ivar true EXIT THEN THEN 4 ++> addr \ no match yet - look at next link AGAIN ;f : (findM) ( selID ^class search_offset methSearch? -- offs ^mcfa true | false ) -> methsearch? -> sch_offset swap -> sch_selID (* Now before we start the search, we have to initialize meth_seg# in case we find the method straight away. last_RP_seg# will be the seg# of the current class, since the caller will have just done @abs on the reloc pointer to the class. But if the class is exported, last_RP_seg# will refer to the exported entry, not the seg# of the module. However, in this case heldmod will be nonzero, and we can pick up the seg# from offset 4 from heldmod. *) heldmod IF heldmod 4+ w@ ELSE last_RP_seg# THEN -> meth_seg# ( ^class ) sch_in_class ; : SFIND ( str-addr len -- xt flag | str-addr false ) pad place case_in_names? NIF pad count upper THEN pad find ; :f DEFINED? ( -- xt flag | str-addr false ) Mword find ;f \ Note: ' and ['] are in qpCond, since we still need the 68k versions \ before then. \ ============================= \ COMPILATION \ ============================= forward ppc_compile \ in cg6 (* (COMP) ( xt -- ) Compiles the word with the given xt. All compilation should be done via this word or (COMPN), since fooling the code generator by bypassing it probably isn't a good idea. This word assumes a zero opcode is to be passed to the generator. If not, use (COMPN). *) : (COMP) ( xt -- ) dup 2- w@ 0 ppc_compile ; \ ANSI synonym: : COMPILE, (comp) ; \ (COMPN) ( xt n -- ) is similar to (COMP), but has an additional \ parameter n which is the opcode for -> ++> etc. : (COMPN) { xt n -- } xt dup 2- w@ n ppc_compile ; \ Interpretation ( EX-GEN etc. ) is in cg7 which is only loaded in PPC \ mode. This is because EX-GEN needs :NONAME (at least). \ ================================ \ DEFINING WORDS \ ================================ : ((HDR)) { ^newLF \ ^oldLF ^thread -- } CDP thread dup -> ^thread \ head of thread in CONTEXT displace -> ^oldLF ^oldLF ^newLF displ! ^newLF ^thread displ! CDP dup c@ 1+ #align4 ++> CDP $ 80 swap cset ; \ on the 68k we needed to handle both kinds of headers, but only one on the \ PPC. Also, we used to vector HEADER, in case we wanted to do something \ clever, but we never did, so let's not vector it any more. : HEADER { \ ^newLF -- } code_align ?dp CDP -> ^newLF \ this will be where the new link field will go 0 code, CDP -> latest Mword drop ^newLF ((hdr)) ; \ ' (header) -> header : PPC_HEADER header ; : SHDR { addr len \ ^newLF -- } \ Creates a header for the passed-in string. code_align CDP -> ^newLF \ this will be where the new link field will go 0 code, CDP -> latest addr len CDP place CDP count upper ^newLF ((hdr)) ; : (hr) ( nfa link -- ) swap thread tuck - swap ! ; : HIDE \ ( -- ) Hides the name of the current definition from dic searches. latest dup n>link displace (hr) ; immediate : REVEAL \ ( -- ) Makes the current name visible again. latest dup n>link (hr) ; immediate : COLHDR \ ( -- ) Lays down the header for a colon definition. header $ BE00 codeW, ; \ ================================= \ STACK DUMPING, ETC. \ ================================= : .val .r 2 spaces ; ' null vect sPrint : NAME? \ ( addr -- addr b ) dup >name n>count + #align4 2+ over = ; : XT? { xt \ code -- xt b } \ Checks if xt is really a legal xt. xt \ we'll return this xt 2- 3 and IF false EXIT THEN \ 2 less must be aligned xt 2- c@ -> code \ top byte of handler code $ BD = code $ BE = or ; : ?XT \ ( xt -- xt ) xt? NIF ." not a valid xt" 1 die THEN ; : aligned_addr? \ ( ?addr -- ?addr b ) \ Checks if ?addr could really be an aligned address. Used in stack \ dumping when we don't know what a value is, but want to print a \ name if there is one. We have to apply this check first so that \ we don't get an "unmapped address" error. dup 2+ $ FFFFFFFC and NIF false EXIT THEN dup $ F0000000 and IF false EXIT THEN true ; : .ID \ ( ?xt -- ) aligned_addr? NIF drop EXIT THEN name? NIF drop ." (no name)" EXIT THEN >name n>count type ; : CLASS? \ ( ?xt -- ?xt b ) Returns true if ?xt refers to a class. dup 2- w@ dup $ BC1D = if drop true EXIT then \ class_h $ BC2D = if true EXIT then \ class_in_mod_h false ; : CHKCLASS \ ( xt -- xt ) class? ?EXIT .id space 80 die ; 0 value theObj true value gotoMod? : >classRP { ^obj \ ^class tmp -- ^classRP | -- 0 } (* Takes an object address and returns the address of the reloc pointer to the class (which will be somewhere in front of the object's data). Returns zero if the passed-in address isn't an object address. Needs to work for heap as well as dictionary objects. The test is very unlikely (maybe 1/2**24) to indicate a non-object as being an object. To save time we don't do a conservative check on ^obj actually being a legal address (unlike ALIGNED_ADDR?), apart from checking that it is aligned, which is a very quick check. This means we may crash if an aligned but illegal address is passed in. The presumption is that it really is an object address, and that anything else is a comparatively unlikely error. *) false \ guilty until proven innocent ^obj 3 and ?EXIT \ if not aligned, it can't be an obj addr ^obj -> theObj \ save obj addr in theObj - needed sometimes ^obj 4 - w@x -> tmp \ grab ^class offset tmp 3 and ?EXIT \ which must be aligned tmp $ FF00 and $ FF00 = 0EXIT \ and must be $FFxx ^obj 4 - ++> tmp \ now tmp points to the reloc class ptr drop tmp \ which is what we return ; : classRP>class { ^classRP -- ^class | -- 0 } \ Takes the address of a class reloc pointer, and returns the \ real class address, going into a module if necessary. \ Returns zero if the reloc pointer doesn't point to a class. ^classRP @abs class? NIF drop 0 EXIT THEN \ if not a class, orig addr wasn't an obj addr \ drop false flag gotoMod? IF ?>classInMod ELSE true -> gotoMod? THEN ; : >CLASS { ^obj \ ^class tmp -- ^class | -- 0 } (* Converts an object address to its class address, going into a module if necessary. Returns zero if the passed-in address isn't an object address. For other comments, see >classRP. *) ^obj >classRP dup 0EXIT \ out with zero if not a legal object classRP>class ; : >CLASS { ^obj \ ^class tmp -- ^class | -- 0 } (* Converts an object address to its class address. Returns zero if the passed-in address isn't an object address. Needs to work for heap as well as dictionary objects. The test is very unlikely (maybe 1/2**24) to indicate a non-object as being an object. Without tagged storage we can't be absolutely sure. To save time we don't do a conservative check on ^obj actually being a legal address (unlike aligned_addr?), apart from checking that it is aligned, which is a very quick check. This means we may crash if an aligned but illegal address is passed in. The presumption is that it really is an object address, and that anything else is an (unlikely) error. *) false \ guilty until proven innocent ^obj 3 and ?EXIT \ if not aligned, it can't be an obj addr ^obj -> theObj \ save obj addr in theObj - needed sometimes ^obj 4- w@x -> tmp \ grab ^class offset tmp 3 and ?EXIT \ which must be aligned tmp $ FF00 and $ FF00 = 0EXIT \ and must be $FFxx ^obj 4- ++> tmp \ now tmp points to the class ptr (reloc) tmp @abs class? NIF drop EXIT THEN \ if not a class, orig addr wasn't an obj addr -> ^class gotoMod? IF ^class ?>classInMod -> ^class ELSE true -> gotoMod? THEN drop ^class ; : >CLASSXT \ ( ^obj -- ^class | -- 0 ) (* As for >CLASS, but if the class is exported from a module and you are executing in the main dictionary, it gives the cfa of the imported word, without accessing the module. This can be useful if you just want to identify a class without needing all the class info. If you are executing in the module, however, you will get the cfa of the class in the module. The general rule is that the returned cfa will always be the same as if you had just ticked the classname, wherever you are executing. As for >CLASS, zero is returned if the passed-in address doesn't point to an object. *) false -> gotoMod? >class ; : OBJ? \ ( ?^obj -- ?^obj ^class | -- ?^obj 0 ) (* General test for an object. Not completely rigorous, so we shouldn't use it in a TRAV, but pretty good nevertheless. If it is an object, the class is returned, otherwise zero. We do assume the passed-in value may not be a legal address at all, since we want to use this word in stack dumping. *) aligned_addr? NIF 0 EXIT THEN dup >class ; 0 value the_xt : RA? { addr \ instrn -- b } \ Returns true if the addr looks like a return addr. In this \ case it leaves the xt of the branch target in the_xt. addr $ FFFFFFFC and NIF false EXIT THEN addr $ F0000000 and IF false EXIT THEN \ so we don't get an unmapped addr when we do @ \ OK, it's aligned. If there's a bl instrn 4 bytes back from that \ address, it's very likely to be a return addr. addr 4- @ -> instrn instrn $ FC000001 and $ 48000001 = NIF false EXIT THEN instrn 6 << 6 a>> $ FFFFFFFC and addr 4- + 2- -> the_xt true ; :f .objOrRA \ ( addr -- ) obj? dup NIF \ not an obj - check for return addr drop RA? 0EXIT the_xt .id ELSE \ ( ^obj ^class ) swap 12 - (@abs) dup IF .id ELSE drop ." (no name)" THEN ." class: " .id THEN ;f :f (.stk) { start-addr end-addr chkForRA? \ svBase val dpth cnt -- } base -> svBase 0 -> out 0 -> cnt start-addr end-addr > IF ." underflow" cr EXIT THEN start-addr end-addr = IF ." empty" cr EXIT THEN end-addr start-addr - 4/ -> dpth ." depth " dpth . .stk_limit dpth min 4* start-addr + -> end-addr BEGIN ?pause cr fWind? IF cnt 16 >= if dbgr 0 -> cnt else 1 ++> cnt then THEN 10 -> base start-addr @ -> val val 8 .val 16 -> base & $ emit val 6 .r chkForRA? IF space val .objOrRA 3 spaces THEN 4 ++> start-addr start-addr end-addr >= UNTIL svBase -> base cr ;f :f .S -curs ." Stack:" sp@ sp0 false (.stk) ;f : .SEGS { \ ^entry BA len flags -- seg# displ } max_segs 0 DO i 8 * segTable + -> ^entry ^entry @ dup $ 00ffffff and -> len 24 >> -> flags len IF \ something there i 8 + . cr ^entry 4+ @ -> BA BA nilP = IF ." absent" ELSE BA .h ." len " len .h THEN ." flags " flags .h cr THEN LOOP ; endload \ TESTING: (* *** dummycl META :class OBJECT super{ meta } :m aa: 1 2 3 ;m :m bb: 99 aa: self ;m ;class :class cl2 super{ object } object bloggs :m cc: $ 1234 bb: bloggs ;m ;class cl2 myObj *** *) :f RUN { \ x -- } dbgr cr cr 1 2 3 4 .s cr begin query cr begin rest nip 0> while defined? if execute else number then repeat .s cr again ;f :f quit run ;f \ temp so we can catch errors!